home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-04
/
amsf20.zip
/
DGELG.FOR
< prev
next >
Wrap
Text File
|
1992-01-06
|
5KB
|
170 lines
C
C ..................................................................
C
C SUBROUTINE DGELG
C
C PURPOSE
C TO SOLVE A GENERAL SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS.
C
C USAGE
C CALL DGELG(R,A,M,N,EPS,IER)
C
C DESCRIPTION OF PARAMETERS
C R - DOUBLE PRECISION M BY N RIGHT HAND SIDE MATRIX
C (DESTROYED). ON RETURN R CONTAINS THE SOLUTIONS
C OF THE EQUATIONS.
C A - DOUBLE PRECISION M BY M COEFFICIENT MATRIX
C (DESTROYED).
C M - THE NUMBER OF EQUATIONS IN THE SYSTEM.
C N - THE NUMBER OF RIGHT HAND SIDE VECTORS.
C EPS - SINGLE PRECISION INPUT CONSTANT WHICH IS USED AS
C RELATIVE TOLERANCE FOR TEST ON LOSS OF
C SIGNIFICANCE.
C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS
C IER=0 - NO ERROR,
C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR
C PIVOT ELEMENT AT ANY ELIMINATION STEP
C EQUAL TO 0,
C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI-
C CANCE INDICATED AT ELIMINATION STEP K+1,
C WHERE PIVOT ELEMENT WAS LESS THAN OR
C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES
C ABSOLUTELY GREATEST ELEMENT OF MATRIX A.
C
C REMARKS
C INPUT MATRICES R AND A ARE ASSUMED TO BE STORED COLUMNWISE
C IN M*N RESP. M*M SUCCESSIVE STORAGE LOCATIONS. ON RETURN
C SOLUTION MATRIX R IS STORED COLUMNWISE TOO.
C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS
C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS
C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN -
C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL
C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE
C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS
C GIVEN IN CASE M=1.
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C NONE
C
C METHOD
C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH
C COMPLETE PIVOTING.
C
C ..................................................................
C
SUBROUTINE DGELG(R,A,M,N,EPS,IER)
C
C
DIMENSION A(1),R(1)
DOUBLE PRECISION R,A,PIV,TB,TOL,PIVI
IF(M)23,23,1
C
C SEARCH FOR GREATEST ELEMENT IN MATRIX A
1 IER=0
PIV=0.D0
MM=M*M
NM=N*M
DO 3 L=1,MM
TB=DABS(A(L))
IF(TB-PIV)3,3,2
2 PIV=TB
I=L
3 CONTINUE
TOL=EPS*PIV
C A(I) IS PIVOT ELEMENT. PIV CONTAINS THE ABSOLUTE VALUE OF A(I).
C
C
C START ELIMINATION LOOP
LST=1
DO 17 K=1,M
C
C TEST ON SINGULARITY
IF(PIV)23,23,4
4 IF(IER)7,5,7
5 IF(PIV-TOL)6,6,7
6 IER=K-1
7 PIVI=1.D0/A(I)
J=(I-1)/M
I=I-J*M-K
J=J+1-K
C I+K IS ROW-INDEX, J+K COLUMN-INDEX OF PIVOT ELEMENT
C
C PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R
DO 8 L=K,NM,M
LL=L+I
TB=PIVI*R(LL)
R(LL)=R(L)
8 R(L)=TB
C
C IS ELIMINATION TERMINATED
IF(K-M)9,18,18
C
C COLUMN INTERCHANGE IN MATRIX A
9 LEND=LST+M-K
IF(J)12,12,10
10 II=J*M
DO 11 L=LST,LEND
TB=A(L)
LL=L+II
A(L)=A(LL)
11 A(LL)=TB
C
C ROW INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A
12 DO 13 L=LST,MM,M
LL=L+I
TB=PIVI*A(LL)
A(LL)=A(L)
13 A(L)=TB
C
C SAVE COLUMN INTERCHANGE INFORMATION
A(LST)=J
C
C ELEMENT REDUCTION AND NEXT PIVOT SEARCH
PIV=0.D0
LST=LST+1
J=0
DO 16 II=LST,LEND
PIVI=-A(II)
IST=II+M
J=J+1
DO 15 L=IST,MM,M
LL=L-J
A(L)=A(L)+PIVI*A(LL)
TB=DABS(A(L))
IF(TB-PIV)15,15,14
14 PIV=TB
I=L
15 CONTINUE
DO 16 L=K,NM,M
LL=L+J
16 R(LL)=R(LL)+PIVI*R(L)
17 LST=LST+M
C END OF ELIMINATION LOOP
C
C
C BACK SUBSTITUTION AND BACK INTERCHANGE
18 IF(M-1)23,22,19
19 IST=MM+M
LST=M+1
DO 21 I=2,M
II=LST-I
IST=IST-LST
L=IST-M
L=A(L)+.5D0
DO 21 J=II,NM,M
TB=R(J)
LL=J
DO 20 K=IST,MM,M
LL=LL+1
20 TB=TB-A(K)*R(LL)
K=J+L
R(J)=R(K)
21 R(K)=TB
22 RETURN
C
C
C ERROR RETURN
23 IER=-1
RETURN
END